'************************************************************************************
' Copyright © 2003-2005 Kathleen Dollard
'
' This software is provided 'as-is', without any express or implied warranty. In no 
' event will the author be held liable for any damages arising from the use of this
' software.
' 
' You may use this software for any purpose, including commercial applications, 
' and you may redistribute this software as part of application delivery: however, 
' this copyright notice may not be removed and you may not otherwise redistribute 
' this software directly other than providing a link to wwww.gendotnet.com. 
'
' You may alter this software to better server your needs (I'd like to hear about your 
' changes in order to make the software better). If you alter the softwre, you must  
' clearly mark it as altered and must not be misrepresented as the original software.
' nor wholly your original work.
'*************************************************************************************
Option Strict On
Option Explicit On 

Imports System

Namespace KADGen.Utility
   Public Class XmlValidator
      ' NOTE: I'm not implementing disposed, because the 
      '       only way I'm storing a stream is if its passed in.

#Region "Class level declarations"
      Private Const vbcrlf As String = Microsoft.VisualBasic.ControlChars.CrLf
      Private mPrefix As String
      'Private mReport As String
      Private mSbReport As New Text.StringBuilder
      Private mFileName As String
      Private mStream As IO.Stream
      Private mXmlSchema As Xml.Schema.XmlSchema
      Private mSchemaFileName As String
      Private mSchemaResourceType As System.Type
      Private mSchemaResourceName As String
#End Region

#Region "Constructors"
      Public Sub New(ByVal fileName As String, _
               ByVal xmlSchema As Xml.Schema.XmlSchema)
         mFileName = fileName
         mXmlSchema = xmlSchema
      End Sub

      Public Sub New(ByVal stream As IO.Stream, _
               ByVal xmlSchema As Xml.Schema.XmlSchema)
         mStream = stream
         mXmlSchema = xmlSchema
      End Sub

      Public Sub New(ByVal fileName As String, _
               ByVal schemaFileName As String)
         mFileName = fileName
         mSchemaFileName = schemaFileName
      End Sub

      Public Sub New(ByVal stream As IO.Stream, _
               ByVal schemaFileName As String)
         mStream = stream
         mSchemaFileName = schemaFileName
      End Sub

      Public Sub New(ByVal stream As IO.Stream, _
              ByVal schemaResourceName As String, _
              ByVal type As System.Type)
         mStream = stream
         mSchemaResourceName = schemaResourceName
         mSchemaResourceType = type
      End Sub

      Public Sub New(ByVal fileName As String, _
              ByVal schemaResourceName As String, _
              ByVal type As System.Type)
         mFileName = fileName
         mSchemaResourceName = schemaResourceName
         mSchemaResourceType = type
      End Sub
#End Region

#Region "Public properties and methods"

      Public ReadOnly Property Report() As String
         Get
            Return mSbReport.ToString
         End Get
      End Property

      Public Function LoadAndValidate() _
               As Xml.XmlDocument
         Dim xmlDoc As New Xml.XmlDocument
         LoadAndValidate(xmlDoc)
         Return xmlDoc
      End Function

      Public Sub LoadAndValidate( _
               ByVal xmlDoc As Xml.XmlDocument)
         Dim stream As IO.FileStream = Nothing
         If Me.mStream Is Nothing Then
            Try
               stream = New IO.FileStream(Me.mFileName, IO.FileMode.Open)
               LoadAndValidate(stream, xmlDoc)
            Finally
               If Not stream Is Nothing Then
                  stream.Close()
               End If
            End Try
         Else
            LoadAndValidate(Me.mStream, xmlDoc)
         End If
      End Sub

      Public ReadOnly Property Prefix() As String
         Get
            If Me.mPrefix Is Nothing Then
               Dim element As Xml.Schema.XmlSchemaElement
               Dim annot As Xml.Schema.XmlSchemaAnnotation
               Dim markup As Xml.XmlNode()
               element = SchemaRoot
               annot = element.Annotation
               If Not annot Is Nothing Then
                  If TypeOf element.Annotation.Items(0) Is Xml.Schema.XmlSchemaAppInfo Then
                     markup = CType(element.Annotation.Items(0), Xml.Schema.XmlSchemaAppInfo).Markup
                     For Each node As Xml.XmlNode In markup
                        If node.LocalName = "Prefix" Then
                           Me.mPrefix = node.InnerXml
                        End If
                     Next
                  End If
               End If
            End If
            Return Me.mPrefix
         End Get
      End Property

      Public ReadOnly Property TargetNamespace() As String
         Get
            Return Me.XmlSchema.TargetNamespace
         End Get
      End Property

      Public Function NewDoc() As Xml.XmlDocument
         Dim xmlDoc As Xml.XmlDocument
         xmlDoc = New Xml.XmlDocument
         NewDoc(xmlDoc)
         Return xmlDoc
      End Function

      Public Sub NewDoc(ByVal xmlDoc As Xml.XmlDocument)
         Dim root As Xml.XmlNode
         xmlDoc.AppendChild(xmlDoc.CreateXmlDeclaration("1.0", "UTF-8", "yes"))
         AddRequiredElements(xmlDoc)
         root = xmlHelpers.GetRootNode(xmlDoc)
      End Sub

      Public Function NewNode( _
               ByVal xmlDoc As Xml.XmlDocument, _
               ByVal nodeName As String) As Xml.XmlNode
         Dim element As Xml.Schema.XmlSchemaElement
         element = FindElement(nodeName)
         If Not element Is Nothing Then
            Return NewElement(xmlDoc, element)
         End If
         Return Nothing
      End Function
#End Region

#Region "Private properties and methods"
      Private Function LoadAndValidate( _
               ByVal stream As IO.Stream) _
               As Xml.XmlDocument
         Return LoadAndValidate(stream, XmlSchema)
      End Function

      Private Sub LoadAndValidate( _
               ByVal stream As IO.Stream, _
               ByVal xmlDoc As Xml.XmlDocument)
         LoadAndValidate(stream, xmlDoc, XmlSchema)
      End Sub

      Private Function LoadAndValidate( _
               ByVal stream As IO.Stream, _
               ByVal xmlSchema As Xml.schema.XmlSchema) _
               As Xml.XmlDocument
         Dim xmlDoc As New Xml.XmlDocument
         LoadAndValidate(stream, xmlDoc, xmlSchema)
         Return xmlDoc
      End Function

      Private Sub LoadAndValidate( _
               ByVal stream As IO.Stream, _
               ByVal xmlDoc As Xml.XmlDocument, _
               ByVal xmlSchema As Xml.schema.XmlSchema)
         Dim xmlReaderSettings As New Xml.XmlReaderSettings()
         Dim xmlSchemaSet As New Xml.Schema.XmlSchemaSet()
         xmlSchemaSet.Add(xmlSchema)
         xmlReaderSettings.Schemas = xmlSchemaSet
         xmlReaderSettings.ValidationType = Xml.ValidationType.Schema
         AddHandler xmlReaderSettings.ValidationEventHandler, AddressOf ValidationHandler
         Dim validReader As Xml.XmlReader = Nothing
         Dim nodeList As Xml.XmlNodeList
         mSbReport = New Text.StringBuilder
         mSbReport.Append("Issues Validating XML File" & vbcrlf)
         Try
            stream.Position = 0
            validReader = Xml.XmlReader.Create(stream, xmlReaderSettings)
            Try
               xmlDoc.Load(validReader)
            Catch ex As System.Exception
               Throw New System.Exception("Could not validate XML file" & _
                              vbcrlf & vbcrlf & "More Information: " & _
                              vbcrlf & vbcrlf & ex.Message)
            End Try
            ' Check for redundant GUIDs
            Dim guid As String
            Dim outerNodeList As Xml.XmlNodeList
            outerNodeList = xmlDoc.SelectNodes("//*[@Guid]")
            ' KAD 20050206 I had a huge perf problem with the following approach
            'nodeList = xmlDoc.SelectNodes("//*[string-length(@Guid) > 0 and (@Guid=preceding::*/@Guid or @Guid=following::*/@Guid)]")
            'If Not nodeList.Count = 1 Then
            '   Throw New RedundantGuidException(nodeList)
            'End If
            ' KAD 20050206 End of code that should have worked but sometimes had perf issue
            For Each node As Xml.XmlNode In outerNodeList
               guid = Utility.Tools.GetAttributeOrEmpty(node, "Guid")
               If guid.Length > 0 Then
                  nodeList = xmlDoc.SelectNodes("//*[@Guid='" & guid & "']")
                  If nodeList.Count > 1 Then
                     Throw New RedundantGuidException(nodeList)
                  End If
               End If
            Next
         Finally
            If validReader IsNot Nothing Then
               validReader.Close()
            End If
         End Try
      End Sub

      Private Sub ValidationHandler( _
               ByVal sender As Object, _
               ByVal e As Xml.Schema.ValidationEventArgs)
         mSbReport.Append(e.Severity & " : " & e.Message & " : " & e.Exception.Message & vbcrlf)
      End Sub

      Private Function FindElement( _
               ByVal name As String) _
               As Xml.Schema.XmlSchemaElement
         Dim ret As Xml.Schema.XmlSchemaElement
         Dim element As Xml.Schema.XmlSchemaElement = SchemaRoot
         If element.Name = name Then
            Return element
         Else
            If TypeOf element.SchemaType Is Xml.Schema.XmlSchemaComplexType Then
               ret = FindElement(name, CType(element.SchemaType, Xml.Schema.XmlSchemaComplexType))
               If Not ret Is Nothing Then
                  Return ret
               End If
            End If
         End If
         Return Nothing
      End Function

      Private Function FindElement( _
               ByVal name As String, _
               ByVal type As Xml.Schema.XmlSchemaComplexType) _
               As Xml.Schema.XmlSchemaElement
         Dim particle As Xml.Schema.XmlSchemaParticle = type.Particle
         Dim element As Xml.Schema.XmlSchemaElement
         Dim schemaObjectCollection As Xml.Schema.XmlSchemaObjectCollection = Nothing
         Dim ret As Xml.Schema.XmlSchemaElement
         If TypeOf particle Is Xml.Schema.XmlSchemaSequence Then
            schemaObjectCollection = CType(particle, Xml.Schema.XmlSchemaSequence).Items
         ElseIf TypeOf particle Is Xml.Schema.XmlSchemaChoice Then
            schemaObjectCollection = CType(particle, Xml.Schema.XmlSchemaChoice).Items
         End If
         If Not schemaObjectCollection Is Nothing Then
            For Each obj As Xml.Schema.XmlSchemaObject In schemaObjectCollection
               If TypeOf obj Is Xml.Schema.XmlSchemaElement Then
                  If CType(obj, Xml.Schema.XmlSchemaElement).Name = name Then
                     Return CType(obj, Xml.Schema.XmlSchemaElement)
                  Else
                     element = CType(obj, Xml.Schema.XmlSchemaElement)
                     If TypeOf element.SchemaType Is Xml.Schema.XmlSchemaComplexType Then
                        ret = FindElement(name, CType(element.SchemaType, Xml.Schema.XmlSchemaComplexType))
                        If Not ret Is Nothing Then
                           Return ret
                        End If
                     End If
                  End If
               End If
            Next
         End If
         Return Nothing
      End Function

      Private Function GetElements( _
               ByVal xmlSchema As Xml.Schema.XmlSchema) _
               As Xml.Schema.XmlSchemaElement()
         Dim aList As New Collections.ArrayList
         Dim element As Xml.Schema.XmlSchemaElement = SchemaRoot
         Return CType(aList.ToArray(GetType(Xml.Schema.XmlSchemaElement)), Xml.Schema.XmlSchemaElement())
      End Function

      Private Sub AddRequiredElements( _
               ByVal xmlNode As Xml.XmlNode)
         Dim xmlDoc As Xml.XmlDocument
         Dim xmlElement As Xml.Schema.XmlSchemaElement
         If TypeOf xmlNode Is Xml.XmlDocument Then
            xmlDoc = CType(xmlNode, Xml.XmlDocument)
         Else
            xmlDoc = xmlNode.OwnerDocument
         End If
         xmlElement = SchemaRoot()
         AddElement(xmlDoc, xmlNode, xmlElement)
      End Sub

      Private Sub AddElement( _
               ByVal xmldoc As Xml.XmlDocument, _
               ByVal xmlnode As Xml.XmlNode, _
               ByVal element As Xml.Schema.XmlSchemaElement)
         Dim xmlType As Xml.Schema.XmlSchemaType
         Dim childNode As Xml.XmlNode
         If element IsNot Nothing Then
            xmlType = element.SchemaType
            If element.MinOccurs = 1 And element.MaxOccurs = 1 Then
               childNode = xmlnode.AppendChild(NewElement(xmldoc, element))
            End If
         End If
      End Sub

      Private Function NewElement( _
               ByVal xmldoc As Xml.XmlDocument, _
               ByVal element As Xml.Schema.XmlSchemaElement) _
               As Xml.XmlNode
         Dim xmlType As Xml.Schema.XmlSchemaType
         Dim xmlParticle As Xml.Schema.XmlSchemaParticle
         Dim childNode As Xml.XmlNode
         Dim schemaCollection As Xml.Schema.XmlSchemaObjectCollection
         Dim attributes As Xml.Schema.XmlSchemaObjectCollection
         xmlType = element.SchemaType
         childNode = xmldoc.CreateElement( _
                   Prefix, element.QualifiedName.Name, element.QualifiedName.Namespace)
         If TypeOf xmlType Is Xml.Schema.XmlSchemaComplexType Then
            attributes = CType(xmlType, Xml.Schema.XmlSchemaComplexType).Attributes
            For Each attr As Xml.Schema.XmlSchemaAttribute In attributes
               If attr.Name.ToLower = "guid" Then
                  childNode.Attributes.Append(xmlHelpers.NewAttribute(xmldoc, attr.Name, Guid.NewGuid.ToString))
               ElseIf (Not attr.DefaultValue Is Nothing AndAlso attr.DefaultValue.Trim.Length > 0) _
                           Or attr.Use = Xml.Schema.XmlSchemaUse.Required Then
                  childNode.Attributes.Append(xmlHelpers.NewAttribute(xmldoc, attr.Name, attr.DefaultValue))
               End If
            Next
            xmlParticle = CType(xmlType, Xml.Schema.XmlSchemaComplexType).Particle
            If Not xmlParticle Is Nothing Then
               If xmlParticle.MinOccurs = 1 And xmlParticle.MaxOccurs = 1 Then
                  If TypeOf xmlParticle Is Xml.Schema.XmlSchemaAny Then
                     ' KADLOG: We aren't dealing with this yet
                  ElseIf TypeOf xmlParticle Is Xml.Schema.XmlSchemaElement Then
                     ' KADLOG: We aren't dealing with this yet
                  ElseIf TypeOf xmlParticle Is Xml.Schema.XmlSchemaGroupBase Then
                     schemaCollection = CType(xmlParticle, Xml.Schema.XmlSchemaGroupBase).Items
                     For Each schemaobject As Xml.Schema.XmlSchemaObject In schemaCollection
                        If TypeOf schemaobject Is Xml.Schema.XmlSchemaElement Then
                           element = CType(schemaobject, Xml.Schema.XmlSchemaElement)
                           AddElement(xmldoc, childNode, element)
                        Else
                           ' KADLOG: We aren't dealing with this yet
                        End If
                     Next
                  ElseIf TypeOf xmlParticle Is Xml.Schema.XmlSchemaGroupRef Then
                     ' KADLOG: We aren't dealing with this yet
                  End If
               End If
            End If
         Else
            'KADLOG: How can this be a simple type 
         End If
         Return childNode
      End Function

      Private ReadOnly Property SchemaRoot() As Xml.Schema.XmlSchemaElement
         Get
            For Each qname As Xml.XmlQualifiedName In XmlSchema.Elements.Names
               Return CType(XmlSchema.Elements(qname), Xml.Schema.XmlSchemaElement)
            Next
            Return Nothing
         End Get
      End Property

      Private ReadOnly Property XmlSchema() As Xml.Schema.XmlSchema
         Get
            Dim xsdStream As IO.Stream = Nothing
            If mXmlSchema Is Nothing Then
               If Not Me.mSchemaResourceName Is Nothing Then
                  mXmlSchema = Utility.Tools.GetEmbeddedXsd(Me.mSchemaResourceType, Me.mSchemaResourceName)
                  ' TODO: KAD: Add validation handler
                  mXmlSchema.Compile(Nothing)
               Else
                  Try
                     xsdStream = New IO.FileStream(Me.mSchemaFileName, IO.FileMode.Open)
                     mXmlSchema = New Xml.Schema.XmlSchema
                     Xml.Schema.XmlSchema.Read(xsdStream, AddressOf ValidationHandler)
                     If Not Report.Trim.Length = 0 Then
                        ' KADLOG: Log schema issues
                     End If
                  Finally
                     If xsdStream IsNot Nothing Then
                        xsdStream.Close()
                     End If
                  End Try
               End If
            End If
            'KAD: 20060803: The following was removed because documentation says xml schemas are not automatically compiled
            'If Not mXmlSchema.IsCompiled Then
            '   mXmlSchema.Compile(AddressOf ValidationHandler)
            'End If
            Return mXmlSchema
         End Get
      End Property

#End Region

   End Class

   Public Class RedundantGuidException
      Inherits Exception
      Private mNodeList As Xml.XmlNodeList
      Public Sub New(ByVal nodelist As Xml.XmlNodeList)
         MyBase.New("There are redundant Guid values")
         Me.mNodeList = nodelist
      End Sub

      Public ReadOnly Property NodeList() As Xml.XmlNodeList
         Get
            Return mNodeList
         End Get
      End Property

      Public ReadOnly Property FullMessage() As String
         Get
            Dim ret As String
            ret = Me.Message & Tools.vbcrlf
            For Each node As Xml.XmlNode In mNodeList
               ret &= Tools.vbcrlf & node.LocalName & ":" & _
                        Utility.Tools.GetAttributeOrEmpty(node, "Name") & "(" & _
                        Utility.Tools.GetAttributeOrEmpty(node, "Guid") & ")"
            Next
            ret &= Tools.vbcrlf & Tools.vbcrlf & "Remove the incorrect guid. A valid Guid will be created on load. Guids are used to link the Status and User files"
            Return ret
         End Get
      End Property
   End Class
End Namespace